perm filename FILUP.F4[CMS,LCS] blob
sn#100909 filedate 1974-05-06 generic text, type T, neo UTF8
00100 C Q AND R ARE X,Y COORDS. NE(1)=WDCNT. OTHER NE'S HAVE 3
00200 C FOR INVIS. VECTORS. M=VERTICAL SCAN LINES
00300 SUBROUTINE FILLER(Q,R,NE,M,LP,IT)
00400 DIMENSION Q(1),R(1),NE(1)
00500 KK=NE(1)
00600 NX=-10000
00700 JN=NX
00800 KJ=2
00900 DO 4 K=2,KK
01000 IF(NE(K).NE.3)GO TO 11
01100 NE(K)=KJ
01200 KJ=K+1
01300 GO TO 4
01400 11 NE(K)=0
01500 4 CONTINUE
01600 DO 12 K=1,KK
01700 Q(K)=IFIX(Q(K))
01800 12 R(K)=IFIX(R(K))
01900 NE(KK+1)=KJ
02000 C FINDS JUMPS
02100 DO 2 J=2,KK
02200 IF(NE(J).GT.0.OR.Q(J).EQ.Q(J-1))GO TO 2
02300 C SKIPS VERTICAL LINES
02400 XMID=HALF(Q,J)+.00001
02500 C MIDPOINT OF LINE
02600 ALT=HALF(R,J)
02700 C THE ALTITUDE
02800 KJ=0
02900
03000 100 DO 3 L=2,KK
03100 IF(L.EQ.J.OR.NE(L).GT.0)GO TO 3
03200 C NEXT FINDS LINE OVERLAP
03300 IF(MISS(L,XMID,Q))GO TO 3
03400 C NEXT FINDS ALT. OF CROSSING
03500 40 Y=HGHT(L,XMID,Q,R)
03600 IF(Y.LT.ALT)KJ=KJ+1
03700 3 CONTINUE
03800
03900 IF(MOD(KJ,2).EQ.0)GO TO 2
04000 C NEXT IF FOUND A LINE TO DRAW LINES DOWN FROM.
04100 NE(J)=-1
04200 KJ=M
04300 N=Q(J)
04400 L=Q(J-1)
04500 CC IF(IABS(N-L).LE.M)GO TO 2
04600 C SKIPS SEGS SHORTER THAN M INCREMENT.
04700 ALT=.0001
04800 IF(N.GT.L)GO TO 33
04900 KJ=-KJ
05000 ALT=-ALT
05100 33 IF(L.EQ.NX.AND.JN.EQ.J-1)GO TO 17
05200 JA=3
05300 X=-1
05400 17 NX=N
05500 JN=J
05600
05700 CC34 L=L+KJ/2
05800 DO 6 K=L,N,KJ
05900 RK=K
06000 XK=RK
06100 IF(K.EQ.N)ALT=-ALT
06200 C NO SHIFT AT LAST POSITION
06300 RK=RK+ALT
06400 Y=HGHT(J,RK,Q,R)
06500 CC1000 YK=Y-1
06600 IF(X)CALL LINES(XK,Y,JA,LP,IT)
06700 JA=2
06800 H=-10000
06900
07000 18 DO 7 I=2,KK
07100 IF(NE(I).NE.0)GO TO 7
07200 C SKIP IF SAME LINE.
07300 IF(MISS(I,RK,Q))GO TO 7
07400 C TRY NEXT POINT IF IT HIT A -1 LINE.
07500 9 B=HGHT(I,RK,Q,R)
07600 IF(B.GT.Y)GO TO 7
07700 IF(B.LE.H)GO TO 7
07800 H=B
07900 IX=I
08000 C FOUND HIGHEST NEW POINT
08100 7 CONTINUE
08200 IF(H.EQ.Y)GO TO 31
08300 C WIPES OUT THIS LINE SEG.
08400 IF(H.NE.-10000)GO TO 31
08500 NX=-10000
08600 C*** X=1
08700 X=-1
08800 GO TO 6
08900 31 IF(IX.NE.JX.AND.X.GT.0)JA=3
09000 JX=IX
09100 CALL LINES(XK,H,JA,LP,IT)
09200 JA=2
09300 IF(X.GT.0)CALL LINES(XK,Y,JA,LP,IT)
09400 X=-X
09500 600 GO TO 6
09600 6 CONTINUE
09700 2 CONTINUE
09800 RETURN
09900 END
10000
10100 FUNCTION HGHT(J,A,Q,R)
10200 DIMENSION Q(1),R(1)
10300 B=R(J-1)
10400 D=Q(J-1)
10500 F=Q(J)
10600 HGHT=((R(J)-B)*(A-D))/(F-D)+B
10700 IF(F.EQ.D)HGHT=B
10800 RETURN
10900 END
11000
11100 FUNCTION MISS(J,A,Q)
11200 DIMENSION Q(1)
11300 B=Q(J)
11400 C=Q(J-1)
11500 MISS=-1
11600 IF((A.LT.C.AND.A.GT.B).OR.(A.LT.B.AND.A.GT.C))MISS=0
11700 RETURN
11800 END
11900 C MISS=-1, HIT=0
12000
12100 FUNCTION HALF(A,J)
12200 DIMENSION A(1)
12300 HALF=(A(J-1)-A(J))/2.+A(J)
12400 RETURN
12500 END
12600
12700 SUBROUTINE LINES(A,B,J,I,IT)
12800 M=A
12900 N=B
13000 IF(IT.LT.11)GO TO 11
13100 M=B
13200 N=A
13300 11 IF(.NOT.I)GO TO 2
13400 IF(J.EQ.3)GO TO 1
13500 CALL AVECT(M,N)
13600 RETURN
13700 1 CALL AIVECT(M,N)
13800 RETURN
13900 2 CALL PLOT(M,N,J)
14000 RETURN
14100 END